PCGUIA 127/PC Guia 127.iso/Software/Produtividade/OpenOffice.org 2.0.1/openofficeorg1.cab/ModuleControls.xba

Extensible Markup Language | 2005-02-22 | 12KB | 370 lines

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="ModuleControls" script:language="StarBasic">Option Explicit

Public DlgOverwrite as Object
Public Const SBOVERWRITEUNDEFINED as Integer = 0
Public Const SBOVERWRITECANCEL as Integer = 2
Public Const SBOVERWRITEQUERY as Integer = 7
Public Const SBOVERWRITEALWAYS as Integer = 6
Public Const SBOVERWRITENEVER as Integer = 8
Public iGeneralOverwrite as Integer



' Accepts the name of a control and returns the respective control model as object
' The Container can either be a whole document or a specific sheet of a Calc-Document
' 'CName' is the name of the Control
Function getControlModel(oContainer as Object, CName as String)
Dim aForm, oForms as Object
Dim i as Integer
    oForms = oContainer.Drawpage.GetForms
    For i = 0 To oForms.Count-1
        aForm = oForms.GetbyIndex(i)
        If aForm.HasByName(CName) Then
            GetControlModel = aForm.GetbyName(CName)
            Exit Function
        End If
    Next i
    Msgbox("No Control with the name '" & CName & "' found" , 16, GetProductName())
End Function



' Gets the Shape of a Control( e. g. to reset the size or Position of the control
' Parameters:
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' 'CName' is the Name of the Control
Function GetControlShape(oContainer as Object,CName as String)
Dim i as integer
Dim aShape as Object
    For i = 0 to oContainer.DrawPage.Count-1
        aShape = oContainer.DrawPage(i)
        If HasUnoInterfaces(aShape, "com.sun.star.drawing.XControlShape") then
            If ashape.Control.Name = CName then
                GetControlShape = aShape
                exit Function
            End If
        End If
    Next
End Function


' Returns the View of a Control
' Parameters:
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' The 'oController' is always directly attached to the Document
' 'CName' is the Name of the Control
Function getControlView(oContainer , oController as Object, CName as String) as Object
Dim aForm, oForms, oControlModel as Object
Dim i as Integer
    oForms = oContainer.DrawPage.Forms
    For i = 0 To oForms.Count-1
        aForm = oforms.GetbyIndex(i)
        If aForm.HasByName(CName) Then
            oControlModel = aForm.GetbyName(CName)
            GetControlView = oController.GetControl(oControlModel)
            Exit Function
        End If
    Next i
    Msgbox("No Control with the name '" & CName & "' found" , 16, GetProductName())
End Function



' Parameters:
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' 'CName' is the Name of the Control
Function DisposeControl(oContainer as Object, CName as String) as Boolean
Dim aControl as Object

    aControl = GetControlModel(oContainer,CName)
    If not IsNull(aControl) Then
        aControl.Dispose()
        DisposeControl = True
    Else
        DisposeControl = False
    End If
End Function


' Returns a sequence of a group of controls like option buttons or checkboxes
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' 'sGroupName' is the Name of the Controlgroup
Function GetControlGroupModel(oContainer as Object, sGroupName as String )
Dim aForm, oForms As Object
Dim aControlModel() As Object
Dim i as integer

    oForms = oContainer.DrawPage.Forms
    For i = 0 To oForms.Count-1
        aForm = oForms(i)
        If aForm.HasbyName(sGroupName) Then
            aForm.GetGroupbyName(sGroupName,aControlModel)
            GetControlGroupModel = aControlModel
            Exit Function
        End If
    Next i
    Msgbox("No Controlgroup with the name '" & sGroupName & "' found" , 16, GetProductName())
End Function


' Returns the Referencevalue of a group of e.g. option buttons or check boxes
' 'oControlGroup' is a sequence of the Control objects
Function GetRefValue(oControlGroup() as Object)
Dim i as Integer
    For i = 0 To Ubound(oControlGroup())
'        oControlGroup(i).DefaultState = oControlGroup(i).State
        If oControlGroup(i).State Then
            GetRefValue = oControlGroup(i).RefValue
            exit Function
        End If
    Next
    GetRefValue() = -1
End Function


Function GetRefValueOfControlGroup(oContainer as Object, GroupName as String)
Dim oOptGroup() as Object
Dim iRef as Integer
    oOptGroup() = GetControlGroupModel(oContainer, GroupName)
    iRef = GetRefValue(oOptGroup())
    GetRefValueofControlGroup = iRef
End Function


Function GetOptionGroupValue(oContainer as Object, OptGroupName as String) as Boolean
Dim oRulesOptions() as Object
    oRulesOptions() = GetControlGroupModel(oContainer, OptGroupName)
    GetOptionGroupValue = oRulesOptions(0).State
End Function



Function WriteOptValueToCell(oSheet as Object, OptGroupName as String, iCol as Integer, iRow as Integer) as Boolean
Dim bOptValue as Boolean
Dim oCell as Object
    bOptValue = GetOptionGroupValue(oSheet, OptGroupName)
    oCell = oSheet.GetCellByPosition(iCol, iRow)
    oCell.SetValue(ABS(CInt(bOptValue)))
    WriteOptValueToCell() = bOptValue
End Function


Function LoadDialog(Libname as String, DialogName as String, Optional oLibContainer)
Dim oLib as Object
Dim oLibDialog as Object
Dim oRuntimeDialog as Object
    If IsMissing(oLibContainer ) then
        oLibContainer = DialogLibraries
    End If
    oLibContainer.LoadLibrary(LibName)
    oLib = oLibContainer.GetByName(Libname)
    oLibDialog = oLib.GetByName(DialogName)
    oRuntimeDialog = CreateUnoDialog(oLibDialog)
    LoadDialog() = oRuntimeDialog
End Function


Sub GetFolderName(oRefModel as Object)
Dim oFolderDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim RefControlName as String
Dim oUcb as object
    'Note: The following services have to be called in the following order
    ' because otherwise Basic does not remove the FileDialog Service
    oFolderDialog = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker")
    oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
    InitPath = ConvertToUrl(oRefModel.Text)
    If InitPath = "" Then
        InitPath = GetPathSettings("Work")
    End If
    If oUcb.Exists(InitPath) Then
        oFolderDialog.SetDisplayDirectory(InitPath)
    End If
    iAccept = oFolderDialog.Execute()
    If iAccept = 1 Then
        sPath = oFolderDialog.GetDirectory()
        If oUcb.Exists(sPath) Then
            oRefModel.Text = ConvertFromUrl(sPath)
        End If
    End If
End Sub


Sub GetFileName(oRefModel as Object, Filternames())
Dim oFileDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim RefControlName as String
Dim oUcb as object
'Dim ListAny(0)
    'Note: The following services have to be called in the following order
    ' because otherwise Basic does not remove the FileDialog Service
    oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
    oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
    'ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE
    'oFileDialog.initialize(ListAny())
    AddFiltersToDialog(FilterNames(), oFileDialog)
    InitPath = ConvertToUrl(oRefModel.Text)
    If InitPath = "" Then
        InitPath = GetPathSettings("Work")
    End If
    If oUcb.Exists(InitPath) Then
        oFileDialog.SetDisplayDirectory(InitPath)
    End If
    iAccept = oFileDialog.Execute()
    If iAccept = 1 Then
        sPath = oFileDialog.Files(0)
        If oUcb.Exists(sPath) Then
            oRefModel.Text = ConvertFromUrl(sPath)
        End If
    End If
    oFileDialog.Dispose()
End Sub


Function StoreDocument(oDocument as Object, FilterNames() as String, DefaultName as String, DisplayDirectory as String, Optional iAddProcedure as Integer) as String
Dim NoArgs() as New com.sun.star.beans.PropertyValue
Dim oStoreProperties(0) as New com.sun.star.beans.PropertyValue
Dim oStoreDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim ListAny(0) as Long
Dim UIFilterName as String
Dim FilterName as String
Dim FilterIndex as Integer
    ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION_PASSWORD
    oStoreDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
    oStoreDialog.Initialize(ListAny())
    AddFiltersToDialog(FilterNames(), oStoreDialog)
    oStoreDialog.SetDisplayDirectory(DisplayDirectory)
    oStoreDialog.SetDefaultName(DefaultName)
    oStoreDialog.setValue(com.sun.star.ui.dialogs.ExtendedFilePickerElementIds.CHECKBOX_AUTOEXTENSION,0, true)

    iAccept = oStoreDialog.Execute()
    If iAccept = 1 Then
        sPath = oStoreDialog.Files(0)
        UIFilterName = oStoreDialog.GetCurrentFilter()
        FilterIndex = IndexInArray(UIFilterName, FilterNames())
        FilterName = FilterNames(FilterIndex,2)
        If Not IsMissing(iAddProcedure) Then
            Select Case iAddProcedure
                Case 1
                    CommitLastDocumentChanges(sPath)
            End Select
        End If
        On Local Error Goto NOSAVING
        If FilterName = ""  Then
            ' Todo: Catch the case that a document that has to be overwritten is writeportected (e.g. it is open)
            oDocument.StoreAsUrl(sPath, NoArgs())
        Else
            oStoreProperties(0).Name = "FilterName"
            oStoreProperties(0).Value = FilterName
            oDocument.StoreAsUrl(sPath, oStoreProperties())
        End If
    End If
    oStoreDialog.dispose()
    StoreDocument() = sPath
    Exit Function
NOSAVING:
    If Err <> 0 Then
'        Msgbox("Document cannot be saved under '" & ConvertFromUrl(sPath) & "'", 48, GetProductName())
        sPath = ""
        oStoreDialog.dispose()
        Resume NOERROR
        NOERROR:
    End If
End Function


Sub AddFiltersToDialog(FilterNames() as String, oDialog as Object)
Dim i as Integer
Dim MaxIndex as Integer
Dim ViewFiltername as String
Dim oProdNameAccess as Object
Dim sProdName as String
    oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product")
    sProdName = oProdNameAccess.getByName("ooName")
    MaxIndex = Ubound(FilterNames(), 1)
    For i = 0 To MaxIndex
        Filternames(i,0) = ReplaceString(Filternames(i,0), sProdName,"%productname%")
        oDialog.AppendFilter(FilterNames(i,0), FilterNames(i,1))
    Next i
    oDialog.SetCurrentFilter(FilterNames(0,0)
End Sub


Sub SwitchMousePointer(oWindowPeer as Object, bDoEnable as Boolean)
Dim oWindowPointer as Object
    oWindowPointer = CreateUnoService("com.sun.star.awt.Pointer")
    If bDoEnable Then
        oWindowPointer.SetType(com.sun.star.awt.SystemPointer.ARROW)
    Else
        oWindowPointer.SetType(com.sun.star.awt.SystemPointer.WAIT)
    End If
    oWindowPeer.SetPointer(oWindowPointer)
End Sub


Sub ShowOverwriteAllDialog(FilePath as String, sTitle as String)
Dim QueryString as String
Dim LocRetValue as Integer
Dim lblYes as String
Dim lblNo as String
Dim lblYesToAll as String
Dim lblCancel as String
Dim OverwriteModel as Object
    If InitResources(GetProductName(), "dbw") Then
        QueryString = GetResText(507)
        QueryString = ReplaceString(QueryString, ConvertFromUrl(FilePath), "<PATH>")
        If Len(QueryString) > 190 Then
            QueryString = DeleteStr(QueryString, ".<BR>")
        End If
        QueryString = ReplaceString(QueryString, chr(13), "<BR>")
        lblYes = GetResText(508)
        lblYesToAll = GetResText(509)
        lblNo = GetResText(510)
        lblCancel = GetResText(511)
        DlgOverwrite = LoadDialog("Tools", "DlgOverwriteAll")
        DlgOverwrite.Title = sTitle
        OverwriteModel = DlgOverwrite.Model
        OverwriteModel.cmdYes.Label = lblYes
        OverwriteModel.cmdYesToAll.Label = lblYesToAll
        OverwriteModel.cmdNo.Label = lblNo
        OverwriteModel.cmdCancel.Label = lblCancel
        OverwriteModel.lblQueryforSave.Label = QueryString
        OverwriteModel.cmdNo.DefaultButton = True
        DlgOverwrite.GetControl("cmdNo").SetFocus()
        iGeneralOverwrite = 999
        LocRetValue = DlgOverwrite.execute()
        If iGeneralOverwrite = 999 Then
            iGeneralOverwrite = SBOVERWRITECANCEL
        End If
        DlgOverwrite.dispose()
    Else
        iGeneralOverwrite = SBOVERWRITECANCEL
    End If
End Sub


Sub SetOVERWRITEToQuery()
    iGeneralOverwrite = SBOVERWRITEQUERY
    DlgOverwrite.EndExecute()
End Sub


Sub SetOVERWRITEToAlways()
    iGeneralOverwrite = SBOVERWRITEALWAYS
    DlgOverwrite.EndExecute()
End Sub


Sub SetOVERWRITEToNever()
    iGeneralOverwrite = SBOVERWRITENEVER
    DlgOverwrite.EndExecute()
End Sub
</script:module>